perm filename T1.F4[M11,LCS]5 blob
sn#414619 filedate 1979-01-30 generic text, type T, neo UTF8
00100 C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
00200 SUBROUTINE TRANS(JJJ)
00300 CIN DIMENSION IINS(108)
00400 DIMENSION NN(80)
00500 C W(35) FOR PARAMETERS
00600 CIN COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
00700 C THE 'ROUT' COMMON BLOCK IS 1ST OUTPUT BLOCK IN 'PASS3'.
00800 COMMON /ROUT/I(200) ,RX(80),JX(80) /TR/LX(12),K
00900 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
01000 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
01100 1,ENDX,J /KNAM/IPLAY,JFLNM /IFIRST/IFIRST,IDT
01200 1 /INST/INST(27)
01300 1 /WDZ/WDZ(14),JWD(12)
01400 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
01500 COMMON LL /P/W(1) /CONV/ICONV /FQDR/FQDR(28,27),INSN
01600 INTEGER FQDR
01700 C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
01800 CXX DOUBLE PRECISION IDBL,JANP,JBLA,JFLNM,JDBG,
01900 CXX 1 INST,INAM,JSEMI,ICOLON
02000 EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
02100 1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
02200 1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
02300 1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
02400 CXX DATA LX/' ',';', '*','/','-','+'
02500 CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
02600 C****************CHECK NEAR HERE FOR NEEDED CHANGES **************.
02700 C THE BIG NUMBER BELOW IS A LEFT ARROW.
02800
02900 DATA LX/' ',';', '*','/','-','+'
03000 1,"575004020100,'=','<' ,',' ,'(', ')'/,
03100 1 IDOT/'.'/, IDEV/1/,JPRNT/1/,JFLNM/'TRNS'/
03200 1,JBLA/' '/,JDBG/'# '/,JPERC/'% '/,JSEMI/'; '/
03300 C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
03400 DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./,JQUOT/'" '/
03500 1,JEXP/'! '/,JANP/'& '/,ICONV/-1/,JCOLON/': '/
03600 C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
03700
03800 GO TO (555,500) JJJ
03900 555 IF(IFIRST)404, 5,5
04000 404 IGEN=-1
04100 KA=1
04200 C KA IS POINTER TO INPUT ARRAY
04300 IF(INUM.NE.0)GO TO 30
04400 DO 411 K=1,27
04500 411 INST(K)=0
04600 CIN DO 411 K=1,108
04700 CIN411 IINS(K)=0
04800 C ZERO OUT INSTR. NAME ARRAY.
04900 30 IPLAY=0
05000 ENDX=0
05100 KK=0
05200 JSEM=0
05300 INS=-1
05400 402 IDEV=1
05500 412 TYPE 1
05600 1 FORMAT(' INPUT? '$)
05700 100 FORMAT(' >'$)
05800 2 FORMAT(A4)
05900 ACCEPT 2,IDBL
06000 C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
06100 IF(IDBL.NE.JBLA)GO TO 400
06200 IDEV=5
06300 GO TO 5
06400 400 IF(IDBL.NE.JANP)GO TO 602
06500 JPRNT=-JPRNT
06600 GO TO 412
06700 C!*** & IS PRNT-NOPRNT FLIPFLOP
06800 602 IF(IDBL.NE.JQUOT)GO TO 408
06900 C!*** " FOR INSTRUMENT LIST.
07000 DO 606 K=1,INUM
07100 JK=INSNUM(K)
07200 MM=NPAR(JK)-2
07300 606 TYPE 607,INST(K),JK,MM
07400 CIN606 TYPE 607,(INST(K,L),L=1,4),JK,NPAR(JK)
07500 CC606 TYPE 607,(INST(K,L),L=1,4),INSNUM(K),JK
07600 GO TO 402
07700 607 FORMAT(1X,A4,' INS#',I2,' PARAMS=',I2)
07800 CIN607 FORMAT(1X,4A1,' NUM=',I2,' PARAMS=',I2)
07900 C!*** PRINTS INST INFO.
08000 408 IF(IDBL.NE.JEXP)GO TO 603
08100 C TRIGGERS ICONV FLIPFLOP
08200 IF(ICONV)GO TO 2408
08300 ICONV=-1
08400 TYPE 3408
08500 GO TO 412
08600 2408 ICONV=0
08700 TYPE 4408
08800 GO TO 412
08900 3408 FORMAT(' OUTPUT=TEST.SND'/)
09000 4408 FORMAT(' OUTPUT=TEST.DAT'/)
09100 603 IF(IDBL.EQ.JPERC)CALL PLAY
09200 C TYPE % TO RE-PLAY SOUND
09300 CXX IF(IDBL.NE.JDBG)GO TO 410
09400 CXX4448 TYPE 4023
09500 CXX4446 TYPE 4445
09600 CXX ACCEPT 51,KI
09700 CXX IF(KI.EQ.0)GO TO 4022
09800 CXX IF(KI.GT.0)GO TO 4447
09900 C******** THIS STUFF FOR DIAGNOSIS
10000 CXX IF(KI.EQ.-1)TYPE 2325,IGEN
10100 CXX IF(KI.EQ.-2)TYPE 2325,IPRNT
10200 CXX IF(KI.EQ.-3)TYPE 2325,IPLAY
10300 CXX IF(KI.EQ.-4)TYPE 2325,JSEM
10400 CXX IF(KI.EQ.-5)TYPE 2325,J
10500 CXX IF(KI.EQ.-6)TYPE 2325,MM
10600 CXX GO TO 4446
10700 CXX4022 IF(IDEV.EQ.1)GO TO 402
10800 C GO BACK TO 'INPUT' OR '>'
10900 CXX GO TO 502
11000 C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
11100 CXX4447 TYPE 2326,LX(KI)
11200 CXX TYPE 2325,LX(KI)
11300 CXX GO TO 4446
11400 CXX4445 FORMAT(' TYPE LX NUMB. '$)
11500 CXX4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
11600 CXX2324 FORMAT(1X12F/)
11700 CXX2325 FORMAT(1X5I/)
11800 2326 FORMAT(1X80A1)
11900 410 IF(IDBL.EQ.JCOLON)CALL EXIT
12000 C TYPE ':' TO EXIT AND CLOSE ALL FILES.
12100 CALL IFILE(1,IDBL)
12200 C NOW IT BELIEVES YOU'VE TYPED A FILE NAME.
12300 CX CALL OPEN(1,IDBL,0,'RDO')
12400 4 FORMAT(80A1)
12500 C****************
12600 CX TYPE 2325,JSEM
12700 CX TYPE 2325,J
12800 CX TYPE 2325,MM
12900
13000 5 IF(KA.NE.1)GO TO 521
13100 502 IF(IDEV.NE.5)GO TO 601
13200 C*******************************
13300 IF(IGEN.NE.2)IGEN=-1
13400 503 TYPE 100
13500 C*******************************
13600 601 KA=1
13700 READ(IDEV,4,END=404)NN
13800 121 DO 421 LEND=80,1,-1
13900 C FIND LAST CHAR. IN LINE
14000 421 IF(NN(LEND).NE.IBLA)GO TO 621
14100 C NOW WE'VE FOUND A BLANK LINE
14200 IF(IDEV.EQ.1)GO TO 601
14300 GO TO 402
14400 621 IF(IDEV.EQ.5)GO TO 521
14500 IF(JPRNT.LT.0)TYPE 2326,(NN(IJI),IJI=1,LEND)
14600 521 IF(KK.EQ.0)JA=0
14700 C KK IS FLAG FOR CONTINUATION LINES.
14800 DO 21 LSEM=KA,LEND
14900 LS=NN(LSEM)
15000 IF(LS.NE.LESS)GO TO 21
15100 KK=0
15200 GO TO 601
15300 21 IF(LS.EQ.ISEMI)GO TO 821
15400 C SET FLAG TO LOOP BACK TO READ ANOTHER LINE
15500 KK=-1
15600 GO TO 721
15700
15800 821 KK=0
15900 C SET KK TO 0 EVERY TIME WE HIT A SEMICOLON
16000 221 IF(LSEM.EQ.1)GO TO 721
16100 KB=LSEM-1
16200 IF(NN(KB).NE.IBLA)GO TO 721
16300 C DELETE BLANKS BEFORE A SEMICOLON
16400 NN(KB)=ISEMI
16500 NN(LSEM)=IBLA
16600 IF(LEND.EQ.LSEM)LEND=LEND-1
16700 LSEM=LSEM-1
16800 GO TO 221
16900 721 IF(JA.EQ.0)GO TO 921
17000 JA=JA+1
17100 I(JA)=IBLA
17200 C INSERT A BLANK IF A CONTINUATION LINE.
17300 921 KC=IBLA
17400 C LEADING BLANKS AND MULTIPLE BLANKS ARE DELETED.
17500 DO 321 KB=KA,LSEM
17600 C LSEM IS CHAR COUNT IN I ARRAY NOW (LOCATES THE SEMI COLON)
17700 K=NN(KB)
17800 IF(K.NE.IBLA)GO TO 1021
17900 IF(KC.EQ.IBLA)GO TO 321
18000 C DELETE STRINGS OF BLANKS
18100 1021 JA=JA+1
18200 I(JA)=K
18300 KC=K
18400 321 CONTINUE
18500 C CURRENTLY CAN STORE 200 CHARS. IN I ARRAY. (ENOUGH FOR 30 PARAMS?)
18600 KA=LSEM+1
18700 IF(KA.GT.LEND)KA=1
18800 IF(KK.NE.0)GO TO 502
18900 C GO READ MORE IF NO SEMICOLON WAS FOUND.
19000 IF(I(1).EQ.ISEMI)GO TO 5
19100 C CATCHES DUPLICATE SEMICOLON
19200 1408 DO 407 K=1,80
19300 407 JX(K)=IBLA
19400 406 MM=0
19500 C INIT VARIOUS THINGS
19600 DO 4061 J=2,80,2
19700 4061 RX(J)=0
19800 J=-1
19900 IPRNT=0
20000 119 JI=0
20100 9 M=0
20200 N=JI+1
20300 6 JI=JI+1
20400 KCHAR=I(JI)
20500 DO 7 L=1,12
20600 7 IF(KCHAR.EQ.LX(L))GO TO 8
20700 C JUMP OUT IF PUNCT., SPACE, SEMI., ETC.
20800 M=M+1
20900 GO TO 6
21000 C!**** NO STRING CAN EXCEED 10 CHARS.
21100 8 IF(M.EQ.0)GO TO 140
21200 IF(M.GT.10)M=10
21300 MM=MM+1
21400 IF(MM.LE.40)GO TO 88
21500 TYPE 888,(I(JJ),JJ=N,N+9)
21600 STOP
21700 888 FORMAT(' LINE TOO LONG -- ',10A1)
21800 88 JJ=I(N)
21900 IF(JJ.GT.'9')GO TO 16
22000 IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
22100 CXX IF(JJ.GT.8249)GO TO 16
22200 CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
22300 C**** 8240='0' 8249='9'
22400 C!***** JUMP IF 1ST CHAR. IS A LETTER.
22500 Y=0
22600 DOT=10.
22700 DO 18 JK=N,N+M-1
22800 KB=I(JK)
22900 IF(KB.NE.IDOT)GO TO 17
23000 DOT=.1
23100 GO TO 18
23200 17 X=NASCI(KB)
23300 C!**** CHANGE ASCII INTO NUMBER
23400 IF(DOT.LT.1)GO TO 19
23500 Y=Y*DOT+X
23600 GO TO 18
23700 19 Y=Y+X*DOT
23800 DOT=DOT/10.
23900 18 CONTINUE
24000 IF(IGEN.EQ.2)Y=Y*100+1000.
24100 C ABOVE PUTS CONSTANTS IN INS DEFINITIONS. PLUS ONLY. LIMIT??
24200 RX(MM*2-1)=Y
24300 RX(MM*2)=-9999.0
24400 GO TO 140
24500
24600 16 JK=MM*2-1
24700 CX JX(JK)=0
24800 CX RX(JK)=0
24900 CX JX(JK+1)=0
25000 CX RX(JK+1)=0
25100 CALL MPACK(M,I(N),JX(JK),N)
25200 C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
25300 IJ=JX(JK)
25400 IF(IJ.GE.0)GO TO 144
25500 C IF IJ < 0, THEN IT'S A LETTER
25600 JX(MM*2)=M
25700 C SAVE THE WD CNT OF POTENTIAL INST. NAME.
25800 GO TO 143
25900 144 IF(IJ.NE.408)GO TO 140
26000 C "WORD" TYPES OUT RESERVED WORD LIST
26100 TYPE 244,WDZ,JWD
26200 TYPE 245
26300 GO TO 503
26400 244 FORMAT(15(1XA4))
26500 245 FORMAT(' %=REPLAY, &=SHOW INPUT, !=SOUND-SIGHT, "=
26600 1INSTS., :=EXIT, CLOSE FILES')
26700 140 IF(IJ.EQ.400)GO TO 5
26800 C 400='PLAY;' THIS CAN BE THROWN AWAY NOW.
26900 143 IF(KCHAR.EQ.IBLA)GO TO 10
27000 IF(L.EQ.8)KCHAR=IAROW
27100 C!::: CHANGE = INTO ←
27200 141 MM=MM+1
27300 KI=MM*2-1
27400 JX(KI)=KCHAR
27500 10 IF(JI.EQ.JA)GO TO 15
27600 C JA POINTS TO LAST CHAR. TO LOOK AT FOR NOW.
27700 1010 IF(I(JI+1).NE.IBLA)GO TO 11
27800 JI=JI+1
27900 GO TO 1010
28000 11 IF(JI.LT.JA)GO TO 9
28100 C NOW WE HAVE ALL ITEMS IN IX ARRAY
28200 IF(MM.GT.1)GO TO 15
28300 C CATCH 'WORD ;' AT END OF LINE
28400 IF(M.EQ.0)GO TO 5
28500 15 MM=MM*2
28600 142 J=-1
28700 IF(INS.LT.0)GO TO 305
28800 IF(INS.EQ.2)GO TO 305
28900 MM=0
29000 INS=-1
29100 C!***** NOW INITIALIZATION COMPLETE
29200 GO TO 5
29300 50 LL=LL-1
29400 IF(IGEN)308,309,309
29500 CC50 IF(IGEN)308,309,309
29600 CC309 LL=LL-1
29700 CC309 IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
29800 309 IF(IJ.EQ.12)IGEN=-1
29900 C!*** FOUND 'END'
30000 GO TO 59
30100 308 W1=1
30200 IK=W2
30300 IF(LL.GT.NPAR(IK))GO TO 56
30400 54 IF(LL.LT.3)LL=3
30500 DO 55 K=LL,NPAR(IK)
30600 55 W(K)=P(K-2)
30700 C!***** GET INFO ALREADY IN PARAMS
30800 56 DO 57 K=3,LL
30900 57 P(K-2)=W(K)
31000 C!**** FILL UP P LIST AGAIN
31100 X=W3
31200 C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
31300 W3=W2
31400 W2=X
31500 58 LL=NPAR(IK)
31600 DO 52 K=5,LL
31700 KI=FQDR(K-4,IK)
31800 IF(KI)53,52,2352
31900 2352 W(K)=RMAG/W(K)
32000 GO TO 52
32100 53 W(K)=RMAG*W(K)
32200 52 CONTINUE
32300 IF(ENDX.LT.W2+P2)ENDX=W2+P2
32400 59 IF(W1.NE.2.)GO TO 592
32500 IF(LL.EQ.2)GO TO 597
32600 C JUMP IF 'END' OF INS DEF.
32700 IF(LL.NE.3)GO TO 595
32800 C JUMP IF NOT AN INST DEF.
32900 PSV=0
33000 SV=35
33100 C EXPLAIN USE OF STORAGE PARAMS!!
33200 INSN=W3
33300 C INS DEF NUM.
33400 DO 586 K=1,28
33500 C CLEAR FREQ-DUR FLAGS FOR THIS INST.
33600 586 FQDR(K,INSN)=0
33700 CC JINS=INUM
33800 C LIST OF INST NAMES MUST FOLLOW 'INS 0 N;' !!!ALWAYS!!!
33900 CIN596 INUM=INUM+1
34000 CIN596 READ(IDEV,2)INST(INUM)
34100 596 READ(IDEV,2,END=587)INAM
34200 IF(INAM.EQ.JSEMI)GO TO 592
34300 C LIST OF INST NAMES TERMINATES WITH ';'.
34400 DO 588 K=1,INUM
34500 IF(INAM.NE.INST(K))GO TO 588
34600 INST(K)=INAM
34700 INSNUM(K)=INSN
34800 GO TO 589
34900 587 PAUSE 'MISSING SEMICOLON'
35000 588 CONTINUE
35100 INUM=INUM+1
35200 INST(INUM)=INAM
35300 CIN READ(IDEV,4)(INST(INUM,K),K=1,4)
35400 CIN IF(INST(INUM,1).EQ.ISEMI)GO TO 599
35500 C LIST OF INST NAMES TERMINATES WITH ';'.
35600 INSNUM(INUM)=INSN
35700 589 IF(JPRNT)TYPE 244,INAM
35800 CIN IF(JPRNT)TYPE 2326,(INST(INUM,K),K=1,4)
35900 GO TO 596
36000 CIN599 INUM=INUM-1
36100
36200 595 DO 593 K=3,LL
36300 X=W(K)
36400 IF(X.LT.0.OR.X.GT.100)GO TO 593
36500 IF(X.GT.PSV)PSV=X
36600 C CHECK FOR OVERLAPPING PARAM NUMS.
36700 593 CONTINUE
36800 IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
36900 1 .AND.W3.NE.115)GO TO 592
37000 C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
37100 C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
37200 X=W3
37300 594 LL=LL+1
37400 W(LL)=SV
37500 SV=SV-1
37600 C DECREMENT THE HIGH PARAM NUM.
37700 IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
37800 CIN IF(SV.LT.PSV)CALL ERROR(5)
37900 C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
38000 IF(X.NE.111.AND.X.NE.104)GO TO 592
38100 IF(X.EQ.111)X=0
38200 IF(X.EQ.104)X=111
38300 GO TO 594
38400
38500 597 NPAR(INSN)=PSV
38600 C SAVE THE HIGHEST PARAM NUM.
38700
38800 592 IF(JPRNT.GE.0)GO TO 591
38900 TYPE 51,LL,(W(K),K=1,LL)
39000 CXX WRITE(22,51)LL,(W(K),K=1,LL)
39100 C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
39200 591 IDT=2
39300 CZZ ???? IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
39400 C OPENS FILE, IF NOT ALREADY OPEN.
39500 CZZ WRITE(21)LL,(W(K),K=1,LL)
39600 RETURN
39700
39800 500 IFIRST=0
39900 IF(IGEN.EQ.0)IGEN=-1
40000 IF(W1.NE.6)GO TO 555
40100 RETURN
40200 C W1=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
40300
40400 306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
40500 IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
40600 IPRNT=0
40700 C!** RESET NO-PRNT FLAG
40800 INS=-1
40900 GO TO 5
41000 CC IF(J.GE.MM-1)GO TO 5
41100 C!** GO READ ANOTHER LINE
41200 305 CALL MSCAN
41300 IF(IJ.EQ.401)GO TO 500
41400 C 401=FINISH WAS FOUND.
41500 IF(IPRNT.LT.0)GO TO 306
41600 IF(JSEM.EQ.0)GO TO 5
41700 GO TO 50
41800 51 FORMAT(I3,35F10.3/)
41900 307 FORMAT('+',F8.2,$)
42000 1307 FORMAT(F10.3)
42100 END
42200
42300 FUNCTION NASCI(N)
42400 DATA IEX/536870912/,IZERO/'0'/
42500 C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
42600 NASCI=(N-IZERO)/IEX
42700 C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
42800 CXX NASCI=N-8240
42900 C THIS FORM FOR PDP11
43000 END
43100